home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / psd.zip / RUNTIME.SCM < prev   
Text File  |  1992-07-10  |  14KB  |  443 lines
  1. ;;;;
  2. ;;;; runtime.scm 1.15
  3. ;;;;
  4. ;;;; psd -- a portable Scheme debugger, version 1.0
  5. ;;;; Copyright (C) 1992 Pertti Kellomaki, pk@cs.tut.fi
  6.  
  7. ;;;; This program is free software; you can redistribute it and/or modify
  8. ;;;; it under the terms of the GNU General Public License as published by
  9. ;;;; the Free Software Foundation; either version 1, or (at your option)
  10. ;;;; any later version.
  11.  
  12. ;;;; This program is distributed in the hope that it will be useful,
  13. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;;; GNU General Public License for more details.
  16.  
  17. ;;;; You should have received a copy of the GNU General Public License
  18. ;;;; along with this program; if not, write to the Free Software
  19. ;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. ;;;; See file COPYING in the psd distribution.
  21.  
  22. ;;;; 
  23. ;;;; Written by Pertti Kellomaki, pk@cs.tut.fi
  24. ;;;;
  25. ;;;; This file contains part of the runtime support for psd. The parts
  26. ;;;; that have to know about the primitive procedures of the
  27. ;;;; implementation are in the file "primitives.scm".
  28.  
  29. ;;;
  30. ;;; List of breakpoints (file, line number)
  31. ;;;
  32.  
  33. (define *psd-breakpoints* '())
  34.  
  35. ;;; Some state variables for the runtime. These have to be settable
  36. ;;; from the outside, so they are now here. A better solution would be
  37. ;;; to make the debugger main loop a closure that would keep track of
  38. ;;; these, and change them when requested.
  39.  
  40. (define *psd-break?* #f)            ; used for stepping thru evaluation
  41. (define *psd-coming-from-line* #f)  ; used for stepping line by line
  42. (define *psd-stepping-by-line* #f)
  43. (define *psd-current-line* #f)      ; used for triggering breakpoints only
  44. (define *psd-hits-this-line* 0)     ; once per line
  45.  
  46. ;;;
  47. ;;; Reset the runtime state.
  48. ;;;
  49.  
  50. (define (psd-reset)
  51.   (set! *psd-breakpoints* '())
  52.   (set! *psd-break?* #f)
  53.   (set! *psd-coming-from-line* #f)
  54.   (set! *psd-stepping-by-line* #f)
  55.   (set! *psd-current-line* #f)
  56.   (set! *psd-hits-this-line* 0)
  57.   'ok)
  58.  
  59. ;;;
  60. ;;; Set a breakpoint.
  61. ;;;
  62.  
  63. (define psd-set-breakpoint 
  64.   (let ((list list) (member member) (cons cons)
  65.             (string-append string-append)
  66.             (number->string number->string))
  67.  
  68.     (lambda (file line)
  69.       (let ((this (list file line)))
  70.     (if (member this *psd-breakpoints*)
  71.         #f
  72.         (set! *psd-breakpoints*
  73.           (cons this
  74.             *psd-breakpoints*))))
  75.       (string-append "Breakpoint at "
  76.              file
  77.              ":"
  78.              (number->string line)))))
  79.  
  80. ;;;
  81. ;;; The debugger command interpreter.
  82. ;;;
  83.  
  84. (define psd-debug 
  85.  
  86.   ;; just to make sure...
  87.   (let ((+ +) (- -) (< <) (= =) (apply apply) (boolean? boolean?)
  88.           (caddr caddr) (cadr cadr) (car car) (cdr cdr) (char? char?)
  89.           (display display) (eq? eq?) (equal? equal?) (for-each for-each)
  90.           (force-output force-output) (input-port? input-port?) (list list)
  91.           (map map) (member member) (min min) (newline newline) (not not)
  92.           (null? null?) (number->string number->string) (number? number?)
  93.           (output-port? output-port?) (pair? pair?) (procedure? procedure?)
  94.           (quotient quotient) (read read) (reverse reverse)
  95.           (string-length string-length) (string? string?) (substring substring)
  96.           (symbol->string symbol->string) (symbol? symbol?)
  97.           (vector-length vector-length) (vector-ref vector-ref)
  98.           (vector? vector?) (write write))
  99.  
  100.  
  101.     (lambda (val set context place
  102.          file-index start-line
  103.          end-line continuation)
  104.     
  105. ;;; qp is taken from slib. I have put it here so that people who do
  106. ;;; not use slib can still use psd. I also took out printing the newline.
  107. ;;;  -pk-
  108. ;;; 
  109. ;;; Qp writes its arguments, separated by spaces to
  110. ;;; (current-output-port).  Qp compresses printing by substituting
  111. ;;; `...'  for substructure it does not have sufficient room to print.
  112. ;;; *qp-width* is the largest number of characters that qp uses.  Qp
  113. ;;; outputs a newline before returning.
  114.  
  115.       (define *psd-qp-width* 80)
  116.  
  117.       (define psd-qp
  118.     (let
  119.         ((+ +) (- -) (< <) (= =) (apply apply) (boolean? boolean?)
  120.            (car car) (cdr cdr) (char? char?) (display display) (eq? eq?)
  121.            (for-each for-each) (input-port? input-port?) (newline newline)
  122.            (not not) (null? null?) (number->string number->string)
  123.            (number? number?) (output-port? output-port?)
  124.            (procedure? procedure?) (string-length string-length)
  125.            (string? string?) (substring substring)
  126.            (symbol->string symbol->string) (symbol? symbol?)
  127.            (vector-length vector-length) (vector-ref vector-ref)
  128.            (vector? vector?) (write write))
  129.       (letrec
  130.           ((num-cdrs
  131.         (lambda (pairs max-cdrs)
  132.           (cond
  133.            ((null? pairs) 0)
  134.            ((< max-cdrs 1) 1)
  135.            ((pair? pairs) (+ 1 (num-cdrs (cdr pairs) (- max-cdrs 1))))
  136.            (else 1))))
  137.      
  138.            (l-elt-room
  139.         (lambda (room pairs)
  140.           (quotient room (num-cdrs pairs (quotient room 8)))))
  141.  
  142.            (qp-pairs
  143.         (lambda (cdrs room)
  144.           (cond
  145.            ((null? cdrs) 0)
  146.            ((not (pair? cdrs))
  147.             (display " . ")
  148.             (+ 3 (qp-obj cdrs (l-elt-room (- room 3) cdrs))))
  149.            ((< 11 room)
  150.             (display #\ )
  151.             ((lambda (used)
  152.                (+ (qp-pairs (cdr cdrs) (- room used)) used))
  153.              (+ 1 (qp-obj (car cdrs) (l-elt-room (- room 1) cdrs)))))
  154.            (else
  155.             (display " ...") 4))))
  156.  
  157.            (v-elt-room
  158.         (lambda (room vleft)
  159.           (quotient room (min vleft (quotient room 8)))))
  160.  
  161.            (qp-vect
  162.         (lambda (vect i room)
  163.           (cond
  164.            ((= (vector-length vect) i) 0)
  165.            ((< 11 room)
  166.             (display #\ )
  167.             ((lambda (used)
  168.                (+ (qp-vect vect (+ i 1) (- room used)) used))
  169.              (+ 1 (qp-obj (vector-ref vect i)
  170.                   (v-elt-room (- room 1)
  171.                           (- (vector-length vect) i))))))
  172.            (else
  173.             (display " ...") 4))))
  174.  
  175.            (qp-string
  176.         (lambda (str room)
  177.           (cond
  178.            ((< (string-length str) room)
  179.             (display str)
  180.             (string-length str))
  181.            (else
  182.             (display (substring str 0 (- room 3)))
  183.             (display "...")
  184.             room))))
  185.  
  186.            (qp-obj
  187.         (lambda (obj room)
  188.           (cond
  189.            ((null? obj) (write obj) 2)
  190.            ((boolean? obj) (write obj) 2)
  191.            ((char? obj) (write obj) 8)
  192.            ((number? obj) (qp-string (number->string obj) room))
  193.            ((string? obj)
  194.             (display #\")
  195.             ((lambda (ans) (display #\") ans)
  196.              (+ 2 (qp-string obj (- room 2)))))
  197.            ((symbol? obj) (qp-string (symbol->string obj) room))
  198.            ((input-port? obj) (display "#[input]") 8)
  199.            ((output-port? obj) (display "#[output]") 9)
  200.            ((procedure? obj) (display "#[proc]") 7)
  201.            ((vector? obj)
  202.             (set! room (- room 3))
  203.             (display "#(")
  204.             ((lambda (used) (display #\)) (+ used 3))
  205.              (cond
  206.               ((= 0 (vector-length obj)) 0)
  207.               ((< room 8) (display "...") 3)
  208.               (else
  209.                ((lambda (used) (+ (qp-vect obj 1 (- room used)) used))
  210.             (qp-obj (vector-ref obj 0)
  211.                 (v-elt-room room (vector-length obj))))))))
  212.            ((pair? obj) 
  213.             (set! room (- room 2))
  214.             (display #\()
  215.             ((lambda (used) (display #\)) (+ 2 used))
  216.              (if (< room 8) (begin (display "...") 3)
  217.              ((lambda (used)
  218.                 (+ (qp-pairs (cdr obj) (- room used)) used))
  219.               (qp-obj (car obj) (l-elt-room room obj))))))
  220.            (else (display "#[unknown]") 10)))))
  221.  
  222.         (lambda objs
  223.           (qp-pairs (cdr objs)
  224.             (- *psd-qp-width*
  225.                (qp-obj (car objs) (l-elt-room *psd-qp-width*
  226.                               objs))))))))
  227.  
  228.  
  229.  
  230.  
  231.       ;; Convert the file index to a string
  232.       (define file-name (psd-index->path file-index))
  233.  
  234.       ;; Prompt the user for commands
  235.       (define (prompt)
  236.     (display "psd> ")
  237.     (force-output)
  238.     (read))
  239.  
  240.       ;; Evaluator for simple procedure calls and set!
  241.       (define (eval form)
  242.     (cond ((and (pair? form)
  243.             (eq? 'set! (car form)))
  244.            (let ((value (eval (caddr form))))
  245.          (set (cadr form) value)
  246.          value))
  247.           ((pair? form)
  248.            (apply (eval (car form))
  249.               (map eval (cdr form))))
  250.           ((symbol? form)
  251.            (val form))
  252.           (else
  253.            form)))
  254.  
  255.       ;; Show the context as file name and a list of procedure names
  256.       (define (show-context)
  257.     (if (null? (context))
  258.         (display "Top level")
  259.         (begin
  260.           (display file-name)
  261.           (display ":")
  262.           (display (reverse (context)))))
  263.     (newline))
  264.  
  265.       ;; Show the position in a format that Emacs can parse
  266.       (define (show-position file line)
  267.     (display psd:control-z)
  268.     (display psd:control-z)
  269.     (display file)
  270.     (display ":")
  271.     (display line)
  272.     (newline))
  273.  
  274.       ;; Check if there is a breakpoint for this line
  275.       (define (break-here? file line)
  276.     (cond
  277.  
  278.      ;; break only if there is a breakpoint for this line, and we
  279.      ;; have just come from somewhere else
  280.      ((and (member (list file line) *psd-breakpoints*)
  281.            (= *psd-hits-this-line* 0)))
  282.      (else #f)))
  283.  
  284.       ;; The top level loop. The top level loop returns either false, in
  285.       ;; which case the program is continued, or a list whose contents
  286.       ;; should be returned as the value of the current expression.
  287.       (define (psd-top-level file-name line entering?)
  288.     (show-position file-name line)
  289.     (let loop ((command (prompt)))
  290.       (case command
  291.         ((val)
  292.          (display (val (read)))
  293.          (newline)
  294.          (loop (prompt)))
  295.         ((set!)
  296.          (let* ((sym (read))
  297.             (val (read)))
  298.            (set sym val))
  299.          (loop (prompt)))
  300.         ((w)
  301.          (show-context)
  302.          (loop (prompt)))
  303.         ((s)
  304.          (set! *psd-stepping-by-line* #f)
  305.          (set! *psd-break?* #t)
  306.          #f)
  307.         ((g)
  308.          (set! *psd-stepping-by-line* #f)
  309.          (set! *psd-break?* #f)
  310.          #f)
  311.         ((n)
  312.          (set! *psd-stepping-by-line* #t)
  313.          (set! *psd-break?* #f)
  314.          (set! *psd-coming-from-line* (list file-name line))
  315.          #f)
  316.         ((r)
  317.          (list (eval (read))))
  318.         (else
  319.          (if (pair? command)
  320.          (begin
  321.            (write (eval command))
  322.            (newline)
  323.            (loop (prompt)))
  324.          (begin
  325.            (display "Commands are:")(newline)
  326.            (display "val sym          give the value of sym")(newline)
  327.            (display "set! sym val     set the value of sym to val")(newline)
  328.            (display "g                run until the next break point")(newline)
  329.            (display "w                give the current context (file name and surrounding procedures)")(newline)
  330.            (display "s                step one step in the evaluation process")(newline)
  331.            (display "n                run until evaluation reaches another line")(newline)
  332.            (display "r expr           return expr as the value of current expression")(newline)
  333.            (display "                 expr can be a procedure call")(newline)
  334.            (newline)
  335.            (display "A list is taken to be a procedure call to be evaluated.")(newline)
  336.            (newline)
  337.            (loop (prompt))))))))
  338.  
  339.  
  340.       ;; Body of psd-debug. First update the line information.
  341.       (let ((position (list file-name start-line)))
  342.     (if (equal? position
  343.             *psd-current-line*)
  344.         (set! *psd-hits-this-line*
  345.           (+ *psd-hits-this-line* 1))
  346.         (begin
  347.           (set! *psd-current-line* position)
  348.           (set! *psd-hits-this-line* 0))))
  349.       
  350.       (if (or *psd-break?*
  351.           (break-here? file-name start-line)
  352.           (and *psd-stepping-by-line*
  353.            (not (equal? (list file-name start-line)
  354.                 *psd-coming-from-line*))))
  355.  
  356.       ;; Breakpoint or stepping
  357.       (begin
  358.         (psd-qp place)
  359.         (newline)
  360.         (let ((top-level-val
  361.            (psd-top-level file-name start-line #t)))
  362.           (if top-level-val
  363.  
  364.           ;; the user wanted to return this value
  365.           (car top-level-val)
  366.  
  367.           (let ((return-value (continuation)))
  368.             (if (or *psd-break?*
  369.                 (break-here? file-name end-line)
  370.                 (and *psd-stepping-by-line*
  371.                  (not (equal? (list file-name end-line)
  372.                           *psd-coming-from-line*))))
  373.             (begin
  374.               (psd-qp place)
  375.               (display " ==> ")
  376.               (write return-value)
  377.               (newline)
  378.               (let ((top-level-val
  379.                  (psd-top-level file-name end-line #f)))
  380.                 (if top-level-val
  381.                 (car top-level-val)
  382.                 return-value)))
  383.  
  384.             return-value)))))
  385.  
  386.       ;; Check if we were called from psd-apply with a #f continuation.
  387.       (if continuation
  388.           (continuation)
  389.           (let loop ((val
  390.               (psd-top-level file-name start-line #t)))
  391.         (if val
  392.             (car val)
  393.             (begin
  394.               (display "This expression can not be evaluated normally.")(newline)
  395.               (display "You have to specify a return value, if you want to continue execution.")
  396.               (newline)
  397.               (loop 
  398.                (psd-top-level file-name start-line #f))))))))))
  399.  
  400.  
  401. ;;;
  402. ;;; Top level definitions of psd-val, psd-set! and psd-context. Each
  403. ;;; time a file is instrumented, two procedures that map the names of
  404. ;;; all top level definitions in the file are written into the file
  405. ;;; that contains the instrumented procedures. When the file is
  406. ;;; loaded, these procedures are added to the lists
  407. ;;; psd-global-symbol-accessors and psd-global-symbol-setters. If the
  408. ;;; user wants to access a global variable, the procedures in the
  409. ;;; appropriate list are called one by one. If none of them has access
  410. ;;; to the variable, the user is notified. The accessor procedures
  411. ;;; return either a list containing the result or #f (I would much
  412. ;;; rather return two values here... sigh!). The setter
  413. ;;; procedures return #t or #f.
  414. ;;;
  415.  
  416. (define psd-val
  417.   (let ((null? null?) (display display) (newline newline)
  418.               (car car) (cdr cdr))
  419.     (lambda (sym)
  420.       (let loop ((procs psd-global-symbol-accessors))
  421.     (if (null? procs)
  422.         (begin (display "Symbol is not visible to psd.")
  423.            (newline)
  424.            #f)
  425.         (let ((result ((car procs) sym)))
  426.           (if result
  427.           (car result)
  428.           (loop (cdr procs)))))))))
  429.  
  430. (define psd-set!
  431.   (let ((null? null?) (display display) (newline newline)
  432.               (car car) (cdr cdr))
  433.     (lambda (sym val)
  434.       (let loop ((procs psd-global-symbol-setters))
  435.     (if (null? procs)
  436.         (begin (display "Symbol is not visible to psd.")
  437.            (newline)
  438.            #f)
  439.         (if ((car procs) sym val)
  440.         #f
  441.         (loop (cdr procs))))))))
  442.  
  443.